home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / HNET / HNET.lisp < prev   
Encoding:
Text File  |  1990-06-24  |  29.1 KB  |  624 lines  |  [TEXT/MACA]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         HNET.LISP
  15. ; Author:       Dan Suthers
  16. ; Created:      20-May-88 23:05:48
  17. ; Modified:     22-Jun-90 02:26:22 (Dan Suthers)
  18. ; Language:     LISP
  19. ; Package:      HNET
  20. ;
  21. ; Description:  Represents simple term hierarchies (directed acyclic graphs
  22. ;               with labeled nodes).  Efficient computation of queries such
  23. ;               as what terms subsume are are subsumed by a given term, and
  24. ;               what the relation between two terms is.
  25. ;
  26. ; (c) Copyright 1988, by Daniel D. Suthers
  27. ;                        Department of Computer and Information Science
  28. ;                        University of Massachusetts
  29. ;                        Amherst, Massachusetts 01003
  30. ;
  31. ; This software was conceived, designed, and written by Dan Suthers 
  32. ; while supported by the National Science Foundation under grant number
  33. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  34. ; CA.  Partial support was also received from the Office of Naval Research
  35. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  36. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  37. ; the above grants and encouraged me to pursue my own research interests in
  38. ; her lab.  This work would not have been possible without the resources and
  39. ; stimulating environment of the Computer and Information Science department.
  40. ;
  41. ; Permission to use, modify, and distribute this software is granted subject 
  42. ; to the following restrictions and understandings:
  43. ; 1. The file header, including this notice, shall be retained, and may be
  44. ;    extended to include documentation of modifications to the software.
  45. ; 2. This material is for nonprofit educational and research purposes only.
  46. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  47. ;    noteworthy uses of this software.
  48. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  49. ;    representation that the operation of this software will be error free,
  50. ;    and are under no obligation to provide any services.
  51. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  52. ;    Suthers and the University of Massachusetts from all claims arising 
  53. ;    out of the use or misuse of this software, or arising out of any 
  54. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  55. ;    fees, and liabilities incurred in or about any such claim, action, or
  56. ;    proceeding brought thereon.
  57. ; 5. All materials and reports developed as a consequence of the use of 
  58. ;    this software shall duly acknowledge such use, in accordance with
  59. ;    the usual standards of acknowledging credit in academic research.
  60. ;
  61. ; Status:       Usable.
  62. ;
  63. ; Tested:       Hewlett Packard 9000       02-Nov-88 Dan Suthers
  64. ;               Macintosh II Coral/Allegro 10-Jan-89 Dan Suthers
  65. ;               Texas Instruments Explorer 02-Nov-88 Dan Suthers DO NOT COMPILE
  66. ;               VAX/VMS                    02-Nov-88 Dan Suthers 
  67. ;
  68. ; Changes:
  69. ;
  70. ;   30-Jun-88 ADD-SUPERORDINATE now returns NIL if action failed due to 
  71. ;     circularity.  This lets using programs know.  DEFINE-TERM does not
  72. ;     have to, since it calls UNDEFINE-TERM on existing terms first, and
  73. ;     I modified the latter to undefine ALL references to the term (not
  74. ;     just backlinks, as before).
  75. ;   02-Jul-88 "symbol" parameters changed to "sym", since TI was confused.
  76. ;   13-Jul-88 Updated for new SM version.
  77. ;   23-Jul-88 Added HNET-ROOTS and SUBORDINATE-LEAVES.
  78. ;   30-Jul-88 Added SUPERORDINATE-MAKES-CYCLE.
  79. ;   01-Nov-88 Documentation changes.
  80. ;   10-Jan-89 Changed to accept any object as a "term", not just symbols. 
  81. ;     (This lets me index DNET-TERMINALs into a HNET, allowing the 
  82. ;     expressions so indexed in a DNET to be organized hierarchically.)
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ;
  85. ;                               About HNET
  86. ;
  87. ;  HNET represents directed acyclic graphs, and provides efficient computation
  88. ;  of hierarchy relations, eg. finding the immediate or transitive predecessors
  89. ;  and successors of a node in the graph, and determining what the subsumption 
  90. ;  relation is between any two nodes.  Each node has an associated object, the
  91. ;  TERM.  A term's predecessors are called 'superordinates', and its successors
  92. ;  are 'subordinates'.  Obviously, an intended application of HNET is to encode
  93. ;  and test subsumption relations in term hierarchies.
  94. ;
  95. ; Creating and Manipulating HNETs:
  96. ;  Each HNET is an SM object.  See CREATE-HNET, HNET, and HNET-INFO (which were
  97. ;  defined by SM in the HNET package).  Also, SM functions such as DESTROYS are
  98. ;  applicable to HNET objects.
  99. ;
  100. ; Defining and Undefining Terms:
  101. ;  See DEFINE-TERM, UNDEFINE-TERM, ADD-SUPERORDINATE, DELETE-SUPERORDINATE,
  102. ;  DEFINED-TERMS, and UNDEFINED-TERMS.
  103. ;
  104. ; Information About a Term:
  105. ;  See DEFINED-P, TERM-INFO, SUPERORDINATES, SUPERORDINATE*, SUBORDINATES, and
  106. ;  SUBORDINATE*.
  107. ;
  108. ; Relation Between Terms:
  109. ;  See SUBSUMPTION-RELATION.
  110. ;
  111. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  112. ;
  113. ;                      Design and Implementation:
  114. ;
  115. ; Speed of queries is optimized, at the expense of speed of defining and
  116. ; undefining terms where necessary.  These are intended to be relatively
  117. ; static networks.
  118. ;
  119. ; Multiple HNETs: All user functions are parameterized by the name of the HNET.
  120. ; To map term names to structures, I use one hash table for each HNET.  The
  121. ; term structures are not SM structures, since these are not objects which
  122. ; a user or programmer will need to edit directly, and we'd have to use
  123. ; generated names anyway.  Superordinate and subordinate slots list objects
  124. ; and the corresponding structure is obtained by hashing into the term table.
  125. ;
  126. ; Deferred Linkages: We allow the user to define a term when its super-
  127. ; ordinates have not been defined, as long as pending definitions are 
  128. ; completed before (that part of) the HNET is used.  Pending linkages 
  129. ; between term nodes in a given HNET are saved in the deferred-linkages
  130. ; slot.  Any time a new term is defined, we attempt to complete these links,
  131. ; as the new term makes possible.
  132. ;
  133. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  134.  
  135. (in-package :HNET)
  136.  
  137. (export '(
  138.  
  139.           ;; Manipulating HNETs (all these defined by SM)
  140.           create-hnet
  141.           hnet
  142.           hnet-info
  143.  
  144.           ;; Defining and undefining the terms and their relations.
  145.           add-superordinate
  146.           define-term
  147.           defined-terms
  148.           delete-superordinate
  149.           superordinate-makes-cycle
  150.           undefine-term
  151.           undefined-terms
  152.  
  153.           ;; Querying the network.
  154.           defined-p
  155.           hnet-roots
  156.           term-info
  157.           subsumption-relation
  158.           subordinate-leaves
  159.           subordinates
  160.           subordinate*
  161.           superordinates
  162.           superordinate*
  163.  
  164.           ))
  165.  
  166. (require :SM) 
  167.  
  168. (proclaim '(optimize (speed 2) (space 2)))
  169.  
  170. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  171. ;;;
  172. ;;;                           DATA STRUCTURES
  173. ;;;
  174. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  175.  
  176. ;;; We save these things as is, including the hash table.
  177.  
  178. (sm:dst (HNET 
  179.          (:reusable nil)
  180.          (:redefine nil)
  181.          (:sort-instances t)
  182.          (:comments "
  183.   Hierarchical NETwork object.  Represents a DAG of terms, for the purpose of
  184.   computing subsumption relations: see the documetation for package HNET.
  185.   HNETs saved to a file are empty when reloaded, due to the hash table in a 
  186.   :compute slot.  Not reusable since there is a lot of space to reclaim in the
  187.   hash table."))
  188.  
  189.         (TERM-TABLE (make-hash-table :test #'eq :size 23)
  190.                     :type hash-table
  191.                     :computed t
  192.                     :comments "
  193.     A hash table associating symbols to CL TERM structures.  Latter record the
  194.     superordinates and subordinates of terms in an HNET.")
  195.  
  196.         (DEFERRED-LINKAGES (list :head)
  197.           :type list
  198.           :computed t
  199.           :comments "
  200.     A list of (<super> . <sub>) entries, where <super> was undefined at the time
  201.     it was declared as a parent of <super>.  This list needs to be checked every
  202.     time a new term is defined, for pending linkages involving that term. :Head
  203.     is for nconc style processing.")
  204.  
  205.         (INFO nil
  206.               :type T
  207.               :computed nil
  208.               :comments "
  209.     The user may associate arbitrary information with the HNET by storing it here.")
  210.         )
  211.  
  212. (defstruct (TERM (:constructor make-term (superordinates info-slot)))
  213.   (superordinates nil :type list)
  214.   (subordinates   nil :type list)
  215.   (info-slot      nil :type T)
  216.   )
  217.  
  218. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  219. ;;;
  220. ;;;                        MACROS (ADT OPERATIONS)
  221. ;;;
  222. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  223.  
  224. ;;; Only used internally. Save space by not loading in compiled files.
  225. (eval-when (compile eval)
  226.   
  227.   (defmacro BACKLINK (obj super hnet-struct)
  228.     ;; Backlink from parent, or push deferred linkage.
  229.     `(let ((super-struct (gethash ,super (hnet-term-table ,hnet-struct))))
  230.        (declare (type term super-struct) (optimize speed))
  231.        (if super-struct
  232.          (pushnew ,obj (term-subordinates super-struct))
  233.          (nconc (hnet-deferred-linkages ,hnet-struct)
  234.                 (list (cons ,super ,obj))))))
  235.   
  236.   (defmacro UNBACKLINK (obj super hnet-struct)
  237.     ;; Remove backpointers from the superordinate.  If it does not exist,
  238.     ;; (<super> . <obj>) is removed from deferred-linkages.
  239.     `(let ((super-struct (gethash ,super (hnet-term-table ,hnet-struct))))
  240.        (declare (type term super-struct) (optimize speed))
  241.        (if super-struct
  242.          (setf (term-subordinates super-struct)
  243.                (delete ,obj (term-subordinates super-struct)))
  244.          (setf (hnet-deferred-linkages ,hnet-struct)
  245.                (delete (cons ,super ,obj)
  246.                        (hnet-deferred-linkages ,hnet-struct) :test #'equal)))))
  247.   
  248.   (defmacro PROCESS-DEFERRED-LINKAGES (new-term hnet-struct)
  249.     ;; Called when <new-term> was just defined in the hnet.
  250.     ;; Hnet-Deferred-linkages is of form (:head (<super> . <sub>) ...). If
  251.     ;; <new-term> occurs as <super>, we need to backlink to <sub> and delete
  252.     ;; the (<super> . <sub>) entry from the list.  The :head lets us delete
  253.     ;; without consing, by manipulating the cdr of a pointer into the list.
  254.     `(do ((dl-ptr (hnet-deferred-linkages ,hnet-struct))
  255.           (term-struct (gethash ,new-term (hnet-term-table ,hnet-struct))))
  256.          ((null (cdr dl-ptr)))
  257.        (declare (list dl-ptr) (type term term-struct) (optimize speed))
  258.        (cond ((eq (caadr dl-ptr) ,new-term)
  259.               ;; Deferred superordinate: backlink and delete entry.  Use pushnew
  260.               ;; since retries may get multiple entries on deferred-linkages.
  261.               (pushnew (cdadr dl-ptr) (term-subordinates term-struct))
  262.               (setf (cdr dl-ptr) (cddr dl-ptr)))
  263.              (T (setf dl-ptr (cdr dl-ptr))))))
  264.   
  265.   (defmacro MAKES-CYCLE (term hnet-struct)
  266.     ;; Returns T if a cycle is found, starting from <term> and searching up.
  267.     ;; Need the <term> parameter because the heirarchy may not be connected.
  268.     `(let ((*hnet-struct* ,hnet-struct))
  269.        (declare (type hnet *hnet-struct*)
  270.                 (special *hnet-struct*)
  271.                 (optimize speed))
  272.        (labels ((cycle-search (term active)
  273.                   (declare (list active) (special *hnet-struct*))
  274.                   (if (member term active) (throw :cycle-catch T))
  275.                   (push term active)
  276.                   ;; The <term> may not be defined in <hnet-struct> yet ... 
  277.                   ;; if not, get its supers as preimage in deferred-linkages.
  278.                   (dolist (super (if (gethash term (hnet-term-table *hnet-struct*))
  279.                                    (term-superordinates 
  280.                                     (gethash term (hnet-term-table *hnet-struct*)))
  281.                                    (do ((ptr (cdr (hnet-deferred-linkages *hnet-struct*))
  282.                                              (rest ptr))
  283.                                         (preimage nil))
  284.                                        ((null ptr) preimage)
  285.                                      (declare (list ptr preimage))
  286.                                      (if (eq (cdar ptr) term)
  287.                                        (pushnew (caar ptr) preimage)))))
  288.                     (cycle-search super active))))
  289.          (catch :cycle-catch (cycle-search ,term nil) nil))))
  290.   
  291.   ;;; For use on a completed hierarchy.  This assumes there are NO cycles,
  292.   ;;; and assumed there are no deferred-linkages.  (Debugging: cycles show
  293.   ;;; up as infinite regress or as two terms being mutually superordinate;
  294.   ;;; deferred-linkages show up as "Error: NIL is not a structure".
  295.   
  296.   (defmacro OCCURS-ABOVE (super-candidate start-term hnet-struct)
  297.     ;; Returns T iff <super-candidate> is a superordinate of <start-term> in
  298.     ;; <hnet-struct>, including the case where they are equal.  (No cycles!)
  299.     `(let ((*super-candidate* ,super-candidate)
  300.            (*term-table*      (hnet-term-table ,hnet-struct)))
  301.        (declare (hash-table *term-table*)
  302.                 (special *super-candidate* *term-table*)
  303.                 (optimize speed))
  304.        (labels ((super-search (term)
  305.                   (declare (special *super-candidate* *term-table*))
  306.                   (if (eq term *super-candidate*) (throw :super-catch T))
  307.                   (dolist (super (term-superordinates (gethash term *term-table*)))
  308.                     (super-search super))))
  309.          (catch :super-catch (super-search ,start-term) nil))))
  310.  
  311.   ) ; end of EVAL-WHEN 
  312.  
  313. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  314. ;;;  
  315. ;;;                             EXPORTED
  316. ;;;
  317. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  318.  
  319. (defun DEFINE-TERM (obj superordinates hnet &optional (info nil))
  320.   "define-term <obj> <superordinates> <hnet>                        [Function]
  321.   Adds <obj> as a term in <hnet>.  If the superordinates do not exist, the
  322.   inverse linking to their children will be deferred until they do exist.
  323.   If the term already is defined, it is undefined first. Returns <obj>." 
  324.   (check-type superordinates list)
  325.   (check-type hnet           symbol)
  326.   (assert (sm:gets 'hnet hnet) (hnet) 
  327.           "[HNET:DEFINE-TERM] HNET ~S is unknown." hnet)
  328.   (let ((hnet-struct (sm:gets 'hnet hnet))
  329.         (term-struct (make-term superordinates info)))
  330.     (declare (type hnet hnet-struct) (type term term-struct))
  331.     ;; If it already exists, undefine it while we know who it was linked to.
  332.     (if (gethash obj (hnet-term-table hnet-struct))
  333.       (undefine-term obj hnet))
  334.     ;; Now it is safe to clobber old entry in the hash table.
  335.     (setf (gethash obj (hnet-term-table hnet-struct)) term-struct)
  336.     ;; Make any linkages the new definition may have enabled.
  337.     (process-deferred-linkages obj hnet-struct)
  338.     (dolist (super superordinates)
  339.       (backlink obj super hnet-struct))
  340.     ;; Due to undefine-term, cycles are not possible, so no check needed here.
  341.     obj))
  342. (proclaim '(function define-term (t list symbol &optional t) t))
  343.  
  344. (defun UNDEFINE-TERM (term hnet)
  345.   "undefine-term <term> <hnet>                                       [Function]
  346.   Removes <term> from the <hnet>, removing all links in both directions.
  347.   Returns <term>."
  348.   (check-type hnet symbol)
  349.   ;; These have to be done outside the following LET so the user has a
  350.   ;; chance to change what LET binds.  Less efficient this way though.
  351.   (assert (sm:gets 'hnet hnet) (hnet)
  352.           "[HNET:UNDEFINE-TERM] HNET ~S is unknown." hnet)
  353.   (assert (defined-p term hnet) (term)
  354.           "[HNET:UNDEFINE-TERM] Term ~S is not defined in ~S." term hnet)
  355.   (let* ((hnet-struct (sm:gets 'hnet hnet))
  356.          (term-struct (gethash term (hnet-term-table hnet-struct))))
  357.     (declare (type hnet hnet-struct) (type term term-struct))
  358.     ;; Remove references to it by its subordinates.
  359.     (dolist (sub (term-subordinates term-struct))
  360.       ;; This is the essence of (delete-superordinate sub term hnet):
  361.       (setf (term-superordinates (gethash sub (hnet-term-table hnet-struct)))
  362.             (delete term (term-superordinates 
  363.                           (gethash sub (hnet-term-table hnet-struct)))))
  364.       (unbacklink sub term hnet-struct))
  365.     ;; Remove references to it by its superordinates.
  366.     (dolist (super (term-superordinates term-struct))
  367.       (unbacklink term super hnet-struct))
  368.     ;; Take it out of the term table..
  369.     (remhash term (hnet-term-table hnet-struct))
  370.     term))
  371. (proclaim '(function undefine-term (T symbol) T))
  372.  
  373. (defun DEFINED-P (obj hnet)
  374.   "defined-p <obj> <hnet>                                           [Function]
  375.   Returns T iff <obj> is defined as a term in the <hnet>."
  376.   (check-type hnet   symbol)
  377.   (assert (sm:gets 'hnet hnet) (hnet)
  378.           "[HNET:DEFINED-P] HNET ~S is unknown." hnet)
  379.   (if (gethash obj (hnet-term-table (the hnet (sm:gets 'hnet hnet)))) T NIL))
  380. (proclaim '(function defined-p (T symbol) T))
  381.  
  382. (defun DEFINED-TERMS (hnet)
  383.   "defined-terms <hnet>                                             [Function]
  384.   Returns a (freshly consed) list of all currently defined terms in <hnet>."
  385.   (check-type hnet symbol)
  386.   (assert (sm:gets 'hnet hnet) (hnet)
  387.           "[HNET:DEFINED-TERMS] HNET ~S is unknown." hnet)
  388.   (let ((defined-terms nil))
  389.     (declare (list defined-terms) 
  390.              (optimize speed))
  391.     (maphash #'(lambda (key entry)
  392.                  (declare (ignore entry))
  393.                  (push key defined-terms))
  394.              (hnet-term-table (the hnet (sm:gets 'hnet hnet))))
  395.     defined-terms))
  396. (proclaim '(function defined-terms (symbol) list))
  397.  
  398. (defun UNDEFINED-TERMS (hnet)
  399.   "undefined-terms <hnet>                                           [Function]
  400.   Returns a list of objects which have been given as the superordinate of
  401.   existing terms in <hnet>, yet are not yet themselves defined as terms."
  402.   (check-type hnet symbol)
  403.   (assert (sm:gets 'hnet hnet) (hnet)
  404.           "[HNET:UNDEFINED-TERMS] HNET ~S is unknown." hnet)
  405.   (delete-duplicates 
  406.    (mapcar #'car (cdr (hnet-deferred-linkages (the hnet (sm:gets 'hnet hnet)))))))
  407. (proclaim '(function undefined-terms (symbol) list))
  408.  
  409. (defun HNET-ROOTS (hnet)
  410.   "hnet-roots <hnet>                                                [Function]
  411.   Returns a list of all terms in <hnet> which have no superordinates."
  412.   (check-type hnet  symbol)
  413.   (assert (sm:gets 'hnet hnet) (hnet)
  414.           "[HNET:HNET-ROOTS] HNET ~S is unknown." hnet)
  415.   (let ((term-table (hnet-term-table (the hnet (sm:gets 'hnet hnet))))
  416.         (roots nil))
  417.     (declare (hash-table term-table) (list roots) (optimize speed))
  418.     (maphash #'(lambda (key term-struct)
  419.                  (declare (type term term-struct))
  420.                  (if (null (term-superordinates term-struct))
  421.                    (push key roots)))
  422.              term-table)
  423.     roots))
  424. (proclaim '(function hnet-roots (symbol) list))
  425.  
  426. (defun SUPERORDINATE-MAKES-CYCLE (term super hnet)
  427.   "superordinate-makes-cycle <term> <super> <hnet>                  [Function]
  428.   Returns T iff (add-superordinate <term> <super> <hnet> would result in
  429.   an error due to creation of a cycle in the HNET."
  430.   (check-type hnet  symbol)
  431.   (assert (sm:gets 'hnet hnet) (hnet)
  432.           "[HNET:SUPERORDINATE-MAKES-CYCLE] HNET ~S is unknown." hnet)
  433.   (assert (defined-p term hnet) (term)
  434.           "[HNET:SUPERORDINATE-MAKES-CYCLE] Term ~S is not defined in ~S." term hnet)
  435.   (let ((hnet-struct (sm:gets 'hnet hnet)))
  436.     (declare (type hnet hnet-struct))
  437.     ;; UGLY way to do it ... Go ahead and define it, test, and undefine.
  438.     (pushnew super (term-superordinates
  439.                     (gethash term (hnet-term-table hnet-struct))))
  440.     (backlink term super hnet-struct)
  441.     (prog1
  442.       (makes-cycle term hnet-struct)
  443.       (delete-superordinate term super hnet))))
  444. (proclaim '(function superordinate-makes-cycle (T T symbol) symbol))
  445.  
  446. (defun ADD-SUPERORDINATE (term super hnet)
  447.   "add-superordinate <term> <super> <hnet>                          [Function]
  448.   Installs <super> as a new superordinate of <term> in <hnet>, deferring
  449.   linkage if <super> does not exist yet.  Cerror if cycle created: if
  450.   continued, the <super> will be undone.  Returns T if the addition 
  451.   succeeded, and NIL if it did not."
  452.   (check-type hnet  symbol)
  453.   ;; These have to be done outside the following LET so the user has a
  454.   ;; chance to change what LET binds.  Less efficient this way though.
  455.   (assert (sm:gets 'hnet hnet) (hnet)
  456.           "[HNET:ADD-SUPERORDINATE] HNET ~S is unknown." hnet)
  457.   (assert (defined-p term hnet) (term)
  458.           "[HNET:ADD-SUPERORDINATE] Term ~S is not defined in ~S." term hnet)
  459.   (let ((hnet-struct (sm:gets 'hnet hnet)))
  460.     (declare (type hnet hnet-struct))
  461.     (pushnew super (term-superordinates 
  462.                     (gethash term (hnet-term-table hnet-struct))))
  463.     (backlink term super hnet-struct)
  464.     (if (makes-cycle term hnet-struct)
  465.       (progn
  466.         (cerror "Will delete this new superordinate."
  467.                 "[HNET:ADD-SUPERORDINATE] ~S's new superordinate ~S creates a cycle in ~S."
  468.                 term super hnet)
  469.         (delete-superordinate term super hnet)
  470.         nil)
  471.       t)))
  472. (proclaim '(function add-superordinate (T T symbol) symbol))
  473.  
  474. (defun DELETE-SUPERORDINATE (term super hnet)
  475.   "delete-superordinate <term> <super> <hnet>                       [Function]
  476.   Removes <super> as a superordinate of <term> in <hnet>, removing all links,
  477.   actual or deferred."
  478.   (check-type hnet  symbol)
  479.   ;; These have to be done outside the following LET so the user has a
  480.   ;; chance to change what LET binds.  Less efficient this way though.
  481.   (assert (sm:gets 'hnet hnet) (hnet)
  482.           "[HNET:DELETE-SUPERORDINATE] HNET ~S is unknown." hnet)
  483.   (assert (defined-p term hnet) (term)
  484.           "[HNET:DELETE-SUPERORDINATE] Term ~S is not defined in ~S." term hnet)
  485.   (let ((hnet-struct (sm:gets 'hnet hnet)))
  486.     (declare (type hnet hnet-struct))
  487.     (setf (term-superordinates (gethash term (hnet-term-table hnet-struct)))
  488.           (delete super (term-superordinates 
  489.                          (gethash term (hnet-term-table hnet-struct)))))
  490.     (unbacklink term super hnet-struct)
  491.     super))
  492. (proclaim '(function delete-superordinate (T T symbol) T))
  493.  
  494. (defmacro TERM-INFO (obj hnet)
  495.   "term-info <term> <hnet>                                             [Macro]
  496.   Setf-able access to the information associated with <term> in <hnet>."
  497.   `(term-info-slot 
  498.     (the term
  499.          (gethash ,obj 
  500.                   (hnet-term-table (the hnet (sm:gets 'hnet ,hnet)))))))
  501.  
  502. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  503. ;;; The remainder of these must be fast, so we are lax on checking arguments,
  504. ;;; only doing so to the extent necessary to prevent a user error from making
  505. ;;; it to deeper code (eg. loops and macros).
  506.  
  507. (defun SUPERORDINATES (term hnet)
  508.   "superordinates <term> <hnet>                                     [Function]
  509.   Returns the IMMEDIATE superordinates of <term> in the <hnet>."
  510.   (term-superordinates 
  511.    (the term
  512.         (gethash term (hnet-term-table (the hnet (sm:gets 'hnet hnet)))))))
  513. (proclaim '(function superordinates (T symbol) list))
  514.  
  515. (defun SUBORDINATES (term hnet)
  516.   "subordinates <term> <hnet>                                       [Function]
  517.   Returns the IMMEDIATE subordinates of <term> in the <hnet>."
  518.   (term-subordinates 
  519.    (the term
  520.         (gethash term (hnet-term-table (the hnet (sm:gets 'hnet hnet)))))))
  521. (proclaim '(function subordinates (T symbol) list))
  522.  
  523. (defun SUPERORDINATE* (term hnet)
  524.   "superordinate* <term> <hnet>                                     [Function]
  525.   Returns ALL (transitive) superordinates of <term> in the <hnet>, 
  526.   including <term>.  The returned list is in order of breadth-first 
  527.   search upwards starting with <term>."
  528.   (let ((hnet-struct (the hnet (sm:gets 'hnet hnet))))
  529.     (declare (type hnet hnet-struct)  (optimize speed))
  530.     ;; This one check makes sure everything is there before getting deep
  531.     ;; into speed optimized code. (If hnet is bad, it will blow up now.)
  532.     (assert (gethash term (hnet-term-table hnet-struct)) (term)
  533.             "[HNET:SUPERORDINATE*] Term ~S is not in HNET ~S" term hnet)
  534.     ;; Frontier is current terms to expand into supers.  Once they are
  535.     ;; expanded, they go onto the list of supers found (preserving order).
  536.     (do ((frontier (list term))
  537.          (new-frontier nil nil)
  538.          (supers (list :head)))
  539.         ((null frontier) (delete-duplicates (cdr supers)))
  540.       (declare (list frontier new-frontier supers))
  541.       (dolist (super frontier)
  542.         (dolist (new-super (term-superordinates
  543.                             (the term 
  544.                                  (gethash super (hnet-term-table hnet-struct)))))
  545.           (push new-super new-frontier)))
  546.       (nconc supers frontier)
  547.       (setf frontier new-frontier))))
  548. (proclaim '(function superordinate* (T symbol) list))
  549.  
  550. (defun SUBORDINATE* (term hnet)
  551.   "subordinate* <term> <hnet>                                       [Function]
  552.   Returns ALL (transitive) subordinates of <term> in the <hnet>,
  553.   including <term>.  The returned list is in order of breadth-first
  554.   search downwards starting with <term>."
  555.   (let ((hnet-struct (the hnet (sm:gets 'hnet hnet))))
  556.     (declare (type hnet hnet-struct)  (optimize speed))
  557.     ;; This one check makes sure everything is there before getting deep
  558.     ;; into speed optimized code. (If hnet is bad, it will blow up now.)
  559.     (assert (gethash term (hnet-term-table hnet-struct)) (term)
  560.             "[HNET:SUBORDINATE*] Term ~S is not in HNET ~S" term hnet)
  561.     ;; Frontier is current terms to expand into subs.  Once they are
  562.     ;; expanded, they go onto the list of subs found (preserving order).
  563.     (do ((frontier (list term))
  564.          (new-frontier nil nil)
  565.          (subs (list :head)))
  566.         ((null frontier) (delete-duplicates (cdr subs)))
  567.       (declare (list frontier new-frontier subs))
  568.       (dolist (sub frontier)
  569.         (dolist (new-sub (term-subordinates 
  570.                           (the term
  571.                                (gethash sub (hnet-term-table hnet-struct)))))
  572.           (push new-sub new-frontier)))
  573.       (nconc subs frontier)
  574.       (setf frontier new-frontier))))
  575. (proclaim '(function subordinate* (T symbol) list))
  576.  
  577. (defun SUBORDINATE-LEAVES (term hnet)
  578.   "subordinate-leaves <term> <hnet>                                 [Function]
  579.   Returns leaf terms which are subordinates of <term> in the <hnet>."
  580.   (let ((hnet-struct (the hnet (sm:gets 'hnet hnet))))
  581.     (declare (type hnet hnet-struct)  (optimize speed))
  582.     (assert (gethash term (hnet-term-table hnet-struct)) (term)
  583.             "[HNET:SUBORDINATE-LEAVES] Term ~S is not in HNET ~S" term hnet)
  584.     (do ((frontier (list term))
  585.          (new-frontier nil nil)
  586.          (leaves (list :head)))
  587.         ((null frontier) (delete-duplicates (cdr leaves)))
  588.       (declare (list frontier new-frontier leaves))
  589.       (dolist (sub frontier)
  590.         (let ((subordinates 
  591.                (term-subordinates
  592.                   (the term (gethash sub (hnet-term-table hnet-struct))))))
  593.           (if (null subordinates)
  594.             (nconc leaves (list sub))
  595.             (dolist (new-sub subordinates)
  596.                (push new-sub new-frontier)))))
  597.       (setf frontier new-frontier))))
  598. (proclaim '(function subordinate-leaves (T symbol) list))
  599.  
  600.  
  601. (defun SUBSUMPTION-RELATION (term1 term2 hnet)
  602.   "subsumption-relation <term1> <term2> <hnet>                      [Function]
  603.   Determines the subsumption relation between two terms in <hnet>.
  604.   Returns :SUBORDINATE if <term1> is a subordinate of <term2>, 
  605.   :SUPERORDINATE for the inverse case, and :INCOMPARABLE if neither 
  606.   subsumes the other.  Heuristic guide: give <term1> the one you 
  607.   suspect is superordinate.  The algorithm checks for this first."
  608.   (let ((hnet-struct (the hnet (sm:gets 'hnet hnet))))
  609.     (declare (type hnet hnet-struct) (optimize speed))
  610.     ;; Safety check, to make optimizing speed safe.
  611.     (assert (and (gethash term1 (hnet-term-table hnet-struct))
  612.                  (gethash term2 (hnet-term-table hnet-struct)))
  613.             (term1 term2)
  614.             "[HNET:SUBSUMPTION-RELATION] One or both terms are not in ~S" hnet)
  615.     (cond ((occurs-above term1 term2 hnet-struct) :superordinate)
  616.           ((occurs-above term2 term1 hnet-struct) :subordinate)
  617.           (T                                      :incomparable))))
  618. (proclaim '(function subsumption-relation (T T symbol) keyword))
  619.  
  620. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  621. (provide :HNET)
  622. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  623. ;;; EOF
  624.